perm filename T2.F4[M11,LCS]1 blob
sn#373980 filedate 1978-08-02 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C00012 ENDMK
Cā;
C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C INTO THE IX ARRAY. IX ARRAY ADVANCES 2 WORDS AT A TIME.
C IF 2ND WRD OF EACH PAIR IS NON-ZERO THEN 1ST IS FLT. PT. NUM.
C KCNT IS WORD COUNT OF INPUT STRING.
SUBROUTINE MPACK(KCNT, I,IX,IPTR)
COMMON/IGEN/IGEN
COMMON /TR/Q(80),QX(100),IIX(100),LX(12),INST(27,5),MX5(40)
DIMENSION I(1)
DATA IPP/'P'/,IFF/'F'/,IBB/'B'/,IAA/'A'/,IOO/'O'/,IRR/'R'/,
1 IEE/'E'/,ISS/'S'/,IMM/'M'/,III/'I'/,ILL/'L'/,ITT/'T'/,
1 IDD/'D'/,I2/'2'/,I3/'3'/,I4/'4'/,IUU/'U'/,ICC/'C'/,IHH/'H'/
1,IVV/'V'/,IYY/'Y'/,IWW/'W'/,I0/'0'/,I9/'9'/,INN/'N'/,IQQ/'Q'/
1,IPP/'P'/,IGG/'G'/
IX=I(1)
DO 100 K=1,12
IF(IX.NE.LX(K))GO TO 100
C LOOK FOR PUNCTUATION, ARITHMETIC OPERATORS, ETC.
RETURN
100 CONTINUE
101 N=I(2)
L=I(3)
IF(IGEN.NE.2)GO TO 1000
C IGEN=2=READING INSTRUMENT DEFINITION
CODE NUMS ARE 1-13 FOR UNIT GENS., 100+ FOR B, 200+ FOR P, 300+ FOR F.
C ORD. OF UNIT GENS:OUT,OSC,AD2,RAN,ENV,STR,AD3,AD4,MLT,SET,RAH,END,INS
IF(IX.EQ.IPP)GO TO 14
IF(IX.EQ.IFF)GO TO 15
IF(IX.EQ.IBB)GO TO 16
IF(IX.EQ.IAA)GO TO 1
IF(IX.EQ.IOO)GO TO 2
IF(IX.EQ.IRR)GO TO 3
IF(IX.EQ.IEE)GO TO 4
IF(IX.EQ.ISS)GO TO 5
IF(IX.EQ.IMM)GO TO 17
IF(IX.EQ.III)GO TO 33
C IF NOT A KNOWN WORD THEN ERROR
999 CALL ERR(5)
C NEXT FOR 'MLT'
17 IF(N.NE.ILL)GO TO 999
IF(L.NE.ITT)GO TO 999
IX=9
RETURN
1 IF(N.NE.IDD)GO TO 999
IF(L.EQ.I2)GO TO 6
C 'AD2, AD3, AD4'
IF(L.EQ.I3)GO TO 7
IF(L.NE.I4)GO TO 999
IX=8
RETURN
6 IX=3
RETURN
7 IX=7
RETURN
2 IF(N.EQ.ISS)GO TO 10
IF(N.NE.IUU)GO TO 200
IF(L.NE.ITT)GO TO 999
C 'OUT'
IX=1
RETURN
200 IF(N.NE.IPP)GO TO 999
IF(L.NE.ITT)GO TO 999
C 'OPT' OPTIONAL USER-ADDED UNIT GENERATOR CODE=14 IN MSCAN.
IX=14
RETURN
10 IF(L.NE.ICC)GO TO 999
C 'OSC'
IX=2
RETURN
3 IF(N.NE.IAA)GO TO 999
IF(L.EQ.INN)GO TO 11
IF(L.NE.IHH)GO TO 999
C 'RAN', 'RAH'
IX=11
RETURN
11 IX=4
RETURN
4 IF(N.NE.INN)GO TO 999
IF(L.EQ.IVV)GO TO 12
C ENV, END
IF(L.NE.IDD)GO TO 999
IX=12
RETURN
12 IX=5
RETURN
5 IF(N.EQ.ITT)GO TO 13
IF(N.NE.IEE)GO TO 999
C SET, STR
IF(L.NE.ITT)GO TO 999
IX=10
RETURN
13 IF(L.NE.IRR)GO TO 999
IX=6
RETURN
14 J=200
C PN
18 IF(N.LT.I0.OR.N.GT.I9)GO TO 999
K2=0
K1=NASCI(N)
CXX K1=N-8240
C CONVERTS ASCII CHAR. TO INTEGER ('0'=8240)
IF(KCNT.EQ.2)GO TO 19
C ARE THERE 2 DIGITS AFTER P, F OR B?
IF(L.LT.I0.OR.L.GT.I9)GO TO 999
K1=K1*10
CXX K2=L-8240
K2=NASCI(L)
19 IX=J+K1+K2
RETURN
15 J=300
C FN
GO TO 18
16 J=100
C BN
GO TO 18
C NEXT FOR OTHER (MUS10 TYPE) KEY WORDS.
1000 IF(KCNT.LE.3)GO TO 2000
C JUMP TO FIND NOTE NAMES, PARAMS, FUNCTS.
LN=I(4)
IF(IX.EQ.IPP)GO TO 20
C THIS LIST BEGINS WITH CODE NUM. 400:
C PLAY,FINI,SRATE,NCHNS,PRINT,CHA,POWER,SRT,GEN,DUR,FREQ,INSTRU,UNIT GEN.
IF(IX.EQ.IFF)GO TO 21
IF(IX.EQ.ISS)GO TO 22
IF(IX.EQ.INN)GO TO 23
IF(IX.EQ.III)GO TO 27
IF(IX.NE.IUU)GO TO 28
C JUMP IF NOT ONE OF THE SPECIAL WORDS. IT MAY BE AN INSTR.
C****** INSTRS CANNOT HAVE SAME NAME(1ST 4 LTRS) AS ANY OF THESE WORDS*******
IF(N.NE.INN)GO TO 28
IF(L.NE.III)GO TO 28
IF(LN.NE.ITT)GO TO 28
C UNIT GEN (FOR SPECIAL DEFINITIONS)
IX=413
RETURN
20 IF(N.NE.ILL)GO TO 30
IF(L.NE.IAA)GO TO 28
IF(LN.NE.IYY)GO TO 28
C PLAY
IX=400
RETURN
30 IF(N.NE.IRR)GO TO 31
IF(L.NE.III)GO TO 28
IF(LN.NE.INN)GO TO 28
C PRINT
IX=404
RETURN
31 IF(N.NE.IOO)GO TO 28
IF(L.NE.IWW)GO TO 28
IF(LN.NE.IEE)GO TO 28
C POWER(X,Y)
IX=406
RETURN
21 IF(N.NE.III)GO TO 32
IF(L.NE.INN)GO TO 28
IF(LN.NE.III)GO TO 28
C UNIT GEN (FOR SPECIAL DEFINITIONS)
IX=401
RETURN
22 IF(N.NE.IRR)GO TO 28
IF(L.EQ.ITT.AND.KCNT.EQ.3)GO TO 222
IF(L.NE.IAA)GO TO 29
IF(LN.NE.ITT)GO TO 28
C SRATE, SRT
222 IX=402
RETURN
29 IF(L.NE.ITT)GO TO 28
IX=407
RETURN
23 IF(N.NE.ICC)GO TO 28
IF(L.NE.IHH)GO TO 28
IF(LN.NE.INN)GO TO 28
C NCHNS
IX=403
RETURN
24 IF(N.NE.IHH)GO TO 28
IF(L.NE.IAA)GO TO 28
C CHA
IX=405
RETURN
25 IF(N.NE.IEE)GO TO 28
IF(L.NE.INN)GO TO 28
C GEN
IX=409
RETURN
26 IF(N.NE.IUU)GO TO 28
IF(L.NE.IRR)GO TO 28
C DUR
IX=410
RETURN
27 IF(N.NE.INN)GO TO 28
IF(L.NE.ISS)GO TO 28
IF(KCNT.EQ.3)GO TO 33
IF(LN.NE.ITT)GO TO 28
IF(I(5).NE.IRR)GO TO 28
IF(I(6).NE.IUU)GO TO 28
C INSTRUMENT
IX=412
RETURN
33 IX=13
C 'INS'
RETURN
32 IF(N.NE.IRR)GO TO 28
IF(L.NE.IEE)GO TO 28
IF(LN.NE.IQQ)GO TO 28
C FREQ
IX=411
RETURN
28 IX=-IPTR
C SEND BACK NEG. POINTER TO I ARRAY SO IT WILL LOOK FOR INST. NAME.
RETURN
2000 IF(IX.EQ.IPP)GO TO 14
C FINDS (P1, P21, ETC.)
IF(IX.EQ.ISS)GO TO 22
C 'SRT'
IF(IX.NE.IFF)GO TO 34
C A FUNC??
IF(N.GE.I0.AND.N.LE.I9)GO TO 15
IF(KCNT.EQ.3)GO TO 28
IX=510
GO TO 36
34 IF(IX.NE.ICC)GO TO 35
IF(KCNT.EQ.3)GO TO 24
C JUMP IF NOT A NOTE
IX=501
C AT THIS POINT NOTE NUMBERS RUN FROM 500 TO 520 (CF TO BS)
GO TO 36
35 IF(IX.NE.IGG)GO TO 38
C NOW A 'GEN' OR A NOTE
IF(KCNT.EQ.3)GO TO 25
IX=513
C THE NOTE 'G'
36 IF(KCNT.EQ.1)RETURN
IF(N.EQ.IFF)GO TO 39
IF(N.NE.ISS) GO TO 28
C NOW IT'S NOT A NOTE
40 IX=IX+1
C SHARP
RETURN
39 IX=IX-1
C FLAT
RETURN
38 IF(IX.NE.IDD)GO TO 41
IF(KCNT.EQ.3)GO TO 26
C GO LOOK FOR 'DUR'
IX=504
GO TO 36
41 IF(IX.EQ.III)GO TO 27
C CATCHES 'INS'
IF(IX.NE.IEE)GO TO 42
IF(KCNT.EQ.3)GO TO 4
C 'END' OR NOTE 'E'?
IX=507
GO TO 36
42 IF(KCNT.EQ.3)GO TO 28
IF(IX.NE.IAA)GO TO 43
IX=516
GO TO 36
43 IF(IX.NE.IBB)GO TO 28
IX=519
GO TO 36
END
SUBROUTINE ERR(N)
GO TO (1,2,3,4,5)N
1 TYPE 101
STOP
101 FORMAT(' MISSING SEMICOLON')
2 TYPE 102
STOP
102 FORMAT(' MISSING PARENTHESIS')
3 TYPE 103
STOP
103 FORMAT(' MISSING COMMA')
4 TYPE 104
104 FORMAT(' MISSING PLAY;')
5 TYPE 105
105 FORMAT(' UNKNOWN WORD')
STOP
END
SUBROUTINE ARITH(Y,W,LL)
DIMENSION W(1)
COMMON /AR/IOP
47 X=W(LL-1)
GO TO (41,42,43,44),IOP
41 X=X*Y
GO TO 45
42 X=X/Y
GO TO 45
43 X=X-Y
GO TO 45
44 X=X+Y
45 W(LL-1)=X
END